home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / slib / fluidlet.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  1.4 KB  |  41 lines
  1. ; "fluidlet.scm", FLUID-LET for Scheme
  2. ; Copyright (c) 1998, Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'dynamic-wind)
  21. (require 'common-list-functions)    ;MAKE-LIST
  22.  
  23. (defmacro fluid-let (clauses . body)
  24.   (let ((ids (map car clauses))
  25.     (new-tmps (map (lambda (x) (gentemp)) clauses))
  26.     (old-tmps (map (lambda (x) (gentemp)) clauses)))
  27.     `(let (,@(map list new-tmps (map cadr clauses))
  28.        ,@(map list old-tmps (make-list (length clauses) #f)))
  29.        (dynamic-wind
  30.        (lambda ()
  31.          ,@(map (lambda (ot id) `(set! ,ot ,id))
  32.             old-tmps ids)
  33.          ,@(map (lambda (id nt) `(set! ,id ,nt))
  34.             ids new-tmps))
  35.        (lambda () ,@body)
  36.        (lambda ()
  37.          ,@(map (lambda (nt id) `(set! ,nt ,id))
  38.             new-tmps ids)
  39.          ,@(map (lambda (id ot) `(set! ,id ,ot))
  40.             ids old-tmps))))))
  41.